home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / olrdrs / catqwk22.zip / CATQWK.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-09  |  10KB  |  354 lines
  1. program catqwk;
  2.  
  3. { CatQWK 2.2
  4.   Sun Feb  9 12:01:40 EST 1992
  5.   by Patrick Y. Lee
  6.   Program to combine one or more QWK files into one.
  7. }
  8.  
  9. {$D-,L-,E-,I-,N-,R-,S-,V-}
  10. {$M 8192, 0, 81920}
  11.  
  12. uses
  13.     crt, dos, strnttt5, qwktpu;
  14.  
  15. const
  16.     message = 'messages.dat';
  17.     sp = ' ';
  18.     crlf = #13 + #10;
  19.     cfg = 'catqwk.cfg';
  20.  
  21. type
  22.     wcptr = ^wildcard;
  23.     wildcard = record
  24.         qwkname : dirstr;
  25.         next : wcptr;
  26.     end;
  27.  
  28. var
  29.     msgoldfh, msgnewfh : file;
  30.     k, tmp : longint;
  31.     workpath, worknew, workold, qwknew, orgdir, compress, decompress : dirstr;
  32.     opt, compopt, decompopt : string [25];
  33.     i, start : byte;
  34.     err : boolean;
  35.     current, first, temp : wcptr;
  36.     f : searchrec;
  37.     e, nummsg : word;
  38.     dir : dirstr;
  39.     name : namestr;
  40.     ext : extstr;
  41.     personal : string [25];
  42.  
  43. label
  44.     break1, break2;
  45.  
  46. procedure doswrite (s : string); { output to screen using DOS }
  47. var
  48.     r : registers;
  49. begin
  50.     s := concat (s, crlf, '$');
  51.     with r do
  52.     begin
  53.         ah := 9;
  54.         ds := seg (s [1]);
  55.         dx := ofs (s [1]);
  56.     end; { with }
  57.     msdos (r);
  58. end; { procedure doswrite }
  59.  
  60. procedure blankline;
  61. begin
  62.     doswrite ('');
  63. end;
  64.  
  65. procedure errormessage (e : byte);              { display error message }
  66. var
  67.     s : string [80];
  68. begin
  69.     case e of
  70.         1 : s := 'Error creating temporary work directory.';
  71.         2 : s := 'Error: You did not specify enough QWK filenames on the command line.';
  72.         3 : s := 'Error extracting first mail packet, ' + current^.qwkname;
  73.         4 : s := 'Error extracting CONTROL.DAT file from mail packet, ' + current^.qwkname + '.';
  74.         5 : s := 'Error extracting message file from mail packet, ' + current^.qwkname + '.';
  75.         6 : s := 'Error concatenating file ' + current^.qwkname + '.';
  76.         7 : s := 'Error compressing the new combined mail packet, ' + qwknew + '.';
  77.         8 : s := 'Cannot find archive utility, make sure it is somewhere on your PATH.';
  78.     end; { case }
  79.     blankline;
  80.     doswrite (s);
  81.     halt (1);
  82. end; { procedure errormessage }
  83.  
  84. { return last x characters from string }
  85. function last (x : byte; temp : string) : string;
  86. begin
  87.     last := copy (temp, length (temp) - x + 1, x);
  88. end; { function last }
  89.  
  90. procedure addslash (var s : dirstr);
  91. begin
  92.     if last (1, s) <> '\' then s := s + '\';
  93. end;
  94.  
  95. { procedure to read the configuration file }
  96. procedure readcfg;
  97. var
  98.     p : byte;
  99.     cfg_fh : text;
  100.     cfg_fn, command, temp, value : string;
  101.  
  102.     procedure compfiles (var sexe, sopt : string);
  103.     begin
  104.         sopt := extractwords (2, 99, sexe);
  105.         sexe := extractwords (1,  1, sexe);
  106.         if not exist (sexe) then sexe := fsearch (sexe, getenv ('path'));
  107.         if not exist (sexe) then errormessage (8);
  108.     end;
  109.  
  110. begin
  111.  
  112.     { default values }
  113.     workpath := '.\';
  114.     compress := 'pkzip.exe -m';
  115.     decompress := 'pkunzip.exe -o';
  116.     personal := '';
  117.  
  118.     { get location of configuration file }
  119.     if exist (cfg) then
  120.         cfg_fn := cfg
  121.     else
  122.     begin
  123.         cfg_fn := getenv ('catqwk');
  124.         if (cfg_fn = '') then
  125.             cfg_fn := lower (fsearch ('catqwk.cfg', getenv ('path')));
  126.         if pos (cfg, cfg_fn) = 0 then
  127.         begin
  128.             addslash (cfg_fn);
  129.             cfg_fn := cfg_fn + cfg;
  130.         end; { if }
  131.     end; { else }
  132.  
  133.     { cannot find configuration file }
  134.     if (exist (cfg_fn)) then
  135.     begin
  136.  
  137.         { open configuration file }
  138.         filemode := 0; { read only }
  139.         assign (cfg_fh, cfg_fn);
  140.         reset (cfg_fh);
  141.  
  142.         { read configuration file }
  143.         repeat
  144.             readln (cfg_fh, temp);
  145.             temp := lower (strip ('b', sp, temp));
  146.             if temp [1] <> ';' then { if line is not a comment }
  147.             begin
  148.                 p := pos ('=', temp) - 1;
  149.                 command := strip ('r', sp, copy (temp, 1, p));
  150.                 value := strip ('l', sp, last (length (temp) - p - 1, temp));
  151.                 if command = 'workpath' then workpath := value;
  152.                 if command = 'compress' then compress := value;
  153.                 if command = 'decompress' then decompress := value;
  154.                 if command = 'personal' then personal := upper (padleft (value, 25, sp));
  155.             end;
  156.         until eof (cfg_fh);
  157.  
  158.         close (Cfg_FH);
  159.  
  160.     end; { if }
  161.  
  162.     { check path name }
  163.  
  164.     addslash (workpath);
  165.     compfiles (compress, compopt);
  166.     compfiles (decompress, decompopt);
  167.  
  168. end; { procedure readcfg }
  169.  
  170. procedure build_ndx_files (var fh : file);      { routine to build NDX }
  171. var                                             { files from MESSAGES.DAT }
  172.     confnum : word;
  173.     buffer : blockformat;
  174.     k, numblock : longint;
  175.     name : string [25];
  176. begin
  177.     blankline;
  178.     doswrite ('Creating index files ...');
  179.     k := 1;
  180.     name [0] := #25;
  181.     seek (fh, k);
  182.     repeat
  183.         blockread (fh, buffer, 1);
  184.         numblock := str_to_int (strip ('B', sp, copy (buffer, 116, 7)));
  185.         if buffer [124] = #32 then
  186.             confnum := ord (buffer [123])
  187.         else
  188.             move (buffer [123], confnum, 2);
  189.         if numblock >= 1 then                   { only write if it is }
  190.         begin                                   { a real message }
  191.             writendx (worknew, confnum, k, false);
  192.             move (buffer [21], name [1], 25);
  193.             if upper (name) = personal then
  194.                 writendx (worknew, confnum, k, true);   { personal message }
  195.             k := k + numblock;                  { next message }
  196.             seek (fh, k);
  197.         end;
  198.     until eof (fh) or (numblock < 1);
  199. end; { procedure build_ndx_files }
  200.  
  201. function decomp (opt : string) : boolean; { true = error, false = good }
  202. begin
  203.     exec (decompress, concat (sp, decompopt, sp, current^.qwkname, sp, opt));
  204.     decomp := (dosexitcode <> 0);
  205. end;
  206.  
  207. procedure addext (var s : dirstr);
  208. begin
  209.     if pos ('.', s) = 0 then s := s + '.qwk';
  210. end;
  211.  
  212. procedure newrec;
  213. begin
  214.     temp := current;
  215.     new (current);
  216.     current^.next := nil;
  217.     temp^.next := current;
  218. end;
  219.  
  220. procedure md (dir : dirstr);
  221. begin
  222.     mkdir (dir);
  223.     if ioresult <> 0 then errormessage (1);
  224. end;
  225.  
  226. begin
  227.  
  228.     blankline;
  229.     doswrite ('CatQWK 2.20 ■ 9 Feb 1992 ■ Copyright 1991-1992 by Patrick Y. Lee ■ Freeware');
  230.  
  231.     if paramcount < 2 then
  232.     begin
  233.         blankline;
  234.         doswrite ('Program to concatenate two or more QWK files into one.');
  235.         blankline;
  236.         doswrite ('Syntax: ' + paramstr (0) + ' [-dworkpath] newqwk oldqwk1 [oldqwk2 ...]');
  237.         halt (1);
  238.     end;
  239.  
  240.     readcfg;
  241.  
  242.     for i := 1 to paramcount do
  243.     begin
  244.         opt := paramstr (i);
  245.         if opt [1] <> '-' then goto break1;
  246.         if opt [2] = 'd' then
  247.         begin
  248.             workpath := copy (opt, 3, ord (opt [0]));
  249.             addslash (workpath);
  250.         end; { if }
  251.     end; { for }
  252.  
  253. break1:
  254.     start := i + 1;
  255.     { create temporary work directories }
  256.     worknew := workpath + '!!!work.new';
  257.     workold := workpath + '!!!work.old';
  258.     md (worknew);
  259.     md (workold);
  260.  
  261.     qwknew := paramstr (i);
  262.     if pos ('.', qwknew) = 0 then qwknew := qwknew + '.qwk';
  263.     inc (i);
  264.  
  265.     if (start > paramcount) then { not enough parameters }
  266.     begin
  267.         rmdir (worknew);
  268.         rmdir (workold);
  269.         errormessage (2); 
  270.     end;
  271.  
  272.     new (current);
  273.     first := current;
  274.     while i <= paramcount do
  275.     begin
  276.         current^.qwkname := paramstr (i);
  277.         current^.next := nil;
  278.         if (pos ('*', current^.qwkname) <> 0) or (pos ('?', current^.qwkname) <> 0) then
  279.         begin
  280.             addext (current^.qwkname);
  281.             current^.qwkname := fexpand (current^.qwkname);
  282.             fsplit (current^.qwkname, dir, name, ext);
  283.             orgdir := dir;
  284.             addslash (orgdir);
  285.             findfirst (current^.qwkname, archive + readonly, f);
  286.             e := doserror;
  287.             while e = 0 do
  288.             begin
  289.                 current^.qwkname := orgdir + f.name;
  290.                 fi